home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_emacs.idb / usr / freeware / share / emacs / 19.34 / lisp / cal-china.el.z / cal-china.el
Encoding:
Text File  |  1998-10-28  |  20.8 KB  |  456 lines
  1. ;;; cal-china.el --- calendar functions for the Chinese calendar.
  2.  
  3. ;; Copyright (C) 1995 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
  6. ;; Keywords: calendar
  7. ;; Human-Keywords: Chinese calendar, calendar, holidays, diary
  8.  
  9. ;; This file is part of GNU Emacs.
  10.  
  11. ;; GNU Emacs is free software; you can redistribute it and/or modify
  12. ;; it under the terms of the GNU General Public License as published by
  13. ;; the Free Software Foundation; either version 2, or (at your option)
  14. ;; any later version.
  15.  
  16. ;; GNU Emacs is distributed in the hope that it will be useful,
  17. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19. ;; GNU General Public License for more details.
  20.  
  21. ;; You should have received a copy of the GNU General Public License
  22. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24. ;; Boston, MA 02111-1307, USA.
  25.  
  26. ;;; Commentary:
  27.  
  28. ;; This collection of functions implements the features of calendar.el,
  29. ;; diary.el, and holidays.el that deal with the Chinese calendar.  The rules
  30. ;; used for the Chinese calendar are those of Baolin Liu (see L. E. Doggett's
  31. ;; article "Calendars" in the Explanatory Supplement to the Astronomical
  32. ;; Almanac, second edition, 1992) for the calendar as revised at the beginning
  33. ;; of the Qing dynasty in 1644.  The nature of the astronomical calculations
  34. ;; is such that precise calculations cannot be made without great expense in
  35. ;; time, so that the calendars produced may not agree perfectly with published
  36. ;; tables--but no two pairs of published tables agree perfectly either!  Liu's
  37. ;; rules produce a calendar for 2033 which is not accepted by all authorities.
  38. ;; The date of Chinese New Year is correct from 1644-2051.
  39.  
  40. ;; Comments, corrections, and improvements should be sent to
  41. ;;  Edward M. Reingold               Department of Computer Science
  42. ;;  (217) 333-6733                   University of Illinois at Urbana-Champaign
  43. ;;  reingold@cs.uiuc.edu             1304 West Springfield Avenue
  44. ;;                                   Urbana, Illinois 61801
  45.  
  46. ;;; Code:
  47.  
  48. (require 'lunar)
  49.  
  50. (defvar chinese-calendar-celestial-stem
  51.   ["Jia" "Yi" "Bing" "Ding" "Wu" "Ji" "Geng" "Xin" "Ren" "Gui"])
  52.  
  53. (defvar chinese-calendar-terrestrial-branch
  54.   ["Zi" "Chou" "Yin" "Mao" "Chen" "Si" "Wu" "Wei" "Shen" "You" "Xu" "Hai"])
  55.  
  56. (defvar chinese-calendar-time-zone 
  57.   '(if (< year 1928)
  58.        (+ 465 (/ 40.0 60.0))
  59.      480)
  60.   "*Number of minutes difference between local standard time for Chinese
  61. calendar and Coordinated Universal (Greenwich) Time.  Default is for Beijing.
  62. This is an expression in `year' since it changed at 1928-01-01 00:00:00 from
  63. UT+7:45:40 to UT+8.")
  64.  
  65. (defvar chinese-calendar-location-name "Beijing"
  66.   "*Name of location used for calculation of Chinese calendar.")
  67.  
  68. (defvar chinese-calendar-daylight-time-offset 0
  69. ; The correct value is as follows, but the Chinese calendrical
  70. ; authorities do NOT use DST in determining astronomical events:
  71. ;  60
  72.   "*Number of minutes difference between daylight savings and standard time
  73. for Chinese calendar.  Default is for no daylight savings time.")
  74.  
  75. (defvar chinese-calendar-standard-time-zone-name
  76.   '(if (< year 1928)
  77.        "PMT"
  78.      "CST")
  79.   "*Abbreviated name of standard time zone used for Chinese calendar.")
  80.  
  81. (defvar chinese-calendar-daylight-time-zone-name "CDT"
  82.   "*Abbreviated name of daylight-savings time zone used for Chinese calendar.")
  83.  
  84. (defvar chinese-calendar-daylight-savings-starts nil
  85. ; The correct value is as follows, but the Chinese calendrical
  86. ; authorities do NOT use DST in determining astronomical events:
  87. ;  '(cond ((< 1986 year) (calendar-nth-named-day 1 0 4 year 10))
  88. ;         ((= 1986 year) '(5 4 1986))
  89. ;         (t nil))
  90.   "*Sexp giving the date on which daylight savings time starts for Chinese
  91. calendar.  Default is for no daylight savings time.  See documentation of
  92. `calendar-daylight-savings-starts'.")
  93.  
  94. (defvar chinese-calendar-daylight-savings-ends nil
  95. ; The correct value is as follows, but the Chinese calendrical
  96. ; authorities do NOT use DST in determining astronomical events:
  97. ;  '(if (<= 1986 year) (calendar-nth-named-day 1 0 9 year 11))
  98.   "*Sexp giving the date on which daylight savings time ends for Chinese
  99. calendar.  Default is for no daylight savings time.  See documentation of
  100. `calendar-daylight-savings-ends'.")
  101.  
  102. (defvar chinese-calendar-daylight-savings-starts-time 0
  103.   "*Number of minutes after midnight that daylight savings time starts for
  104. Chinese calendar.  Default is for no daylight savings time.")
  105.  
  106. (defvar chinese-calendar-daylight-savings-ends-time 0
  107.   "*Number of minutes after midnight that daylight savings time ends for
  108. Chinese calendar.  Default is for no daylight savings time.")
  109.  
  110. (defun chinese-zodiac-sign-on-or-after (d)
  111.   "Absolute date of first new Zodiac sign on or after absolute date d.
  112. The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees."
  113.  (let* ((year (extract-calendar-year
  114.                 (calendar-gregorian-from-absolute d)))
  115.          (calendar-time-zone (eval chinese-calendar-time-zone))
  116.          (calendar-daylight-time-offset
  117.           chinese-calendar-daylight-time-offset)
  118.          (calendar-standard-time-zone-name
  119.           chinese-calendar-standard-time-zone-name)
  120.          (calendar-daylight-time-zone-name
  121.           chinese-calendar-daylight-time-zone-name)
  122.          (calendar-calendar-daylight-savings-starts
  123.           chinese-calendar-daylight-savings-starts)
  124.          (calendar-daylight-savings-ends
  125.           chinese-calendar-daylight-savings-ends)
  126.          (calendar-daylight-savings-starts-time
  127.           chinese-calendar-daylight-savings-starts-time)
  128.          (calendar-daylight-savings-ends-time
  129.           chinese-calendar-daylight-savings-ends-time))
  130.    (floor
  131.     (calendar-absolute-from-astro
  132.      (solar-date-next-longitude
  133.       (calendar-astro-from-absolute d)
  134.       30)))))
  135.  
  136. (defun chinese-new-moon-on-or-after (d)
  137.   "Absolute date of first new moon on or after absolute date d."
  138.   (let* ((year (extract-calendar-year
  139.                 (calendar-gregorian-from-absolute d)))
  140.          (calendar-time-zone (eval chinese-calendar-time-zone))
  141.          (calendar-daylight-time-offset
  142.           chinese-calendar-daylight-time-offset)
  143.          (calendar-standard-time-zone-name
  144.           chinese-calendar-standard-time-zone-name)
  145.          (calendar-daylight-time-zone-name
  146.           chinese-calendar-daylight-time-zone-name)
  147.          (calendar-calendar-daylight-savings-starts
  148.           chinese-calendar-daylight-savings-starts)
  149.          (calendar-daylight-savings-ends
  150.           chinese-calendar-daylight-savings-ends)
  151.          (calendar-daylight-savings-starts-time
  152.           chinese-calendar-daylight-savings-starts-time)
  153.          (calendar-daylight-savings-ends-time
  154.           chinese-calendar-daylight-savings-ends-time))
  155.     (floor
  156.      (calendar-absolute-from-astro
  157.       (lunar-new-moon-on-or-after
  158.        (calendar-astro-from-absolute d))))))
  159.  
  160. (defvar chinese-year-cache
  161.   '((1989 (12 726110) (1 726139) (2 726169) (3 726198) (4 726227) (5 726257)
  162.           (6 726286) (7 726316) (8 726345) (9 726375) (10 726404) (11 726434))
  163.     (1990 (12 726464) (1 726494) (2 726523) (3 726553) (4 726582) (5 726611)
  164.           (5.5 726641) (6 726670) (7 726699) (8 726729) (9 726758) (10 726788)
  165.           (11 726818))
  166.     (1991 (12 726848) (1 726878) (2 726907) (3 726937) (4 726966) (5 726995)
  167.           (6 727025) (7 727054) (8 727083) (9 727113) (10 727142) (11 727172))
  168.     (1992 (12 727202) (1 727232) (2 727261) (3 727291) (4 727321) (5 727350)
  169.           (6 727379) (7 727409) (8 727438) (9 727467) (10 727497) (11 727526))
  170.     (1993 (12 727556) (1 727586) (2 727615) (3 727645) (3.5 727675) (4 727704)
  171.           (5 727734) (6 727763) (7 727793) (8 727822) (9 727851) (10 727881)
  172.           (11 727910))
  173.     (1994 (12 727940) (1 727969) (2 727999) (3 728029) (4 728059) (5 728088)
  174.           (6 728118) (7 728147) (8 728177) (9 728206) (10 728235) (11 728265))
  175.     (1995 (12 728294) (1 728324) (2 728353) (3 728383) (4 728413) (5 728442)
  176.           (6 728472) (7 728501) (8 728531) (8.5 728561) (9 728590) (10 728619)
  177.           (11 728649))
  178.     (1996 (12 728678) (1 728708) (2 728737) (3 728767) (4 728796) (5 728826)
  179.           (6 728856) (7 728885) (8 728915) (9 728944) (10 728974) (11 729004))
  180.     (1997 (12 729033) (1 729062) (2 729092) (3 729121) (4 729151) (5 729180)
  181.           (6 729210) (7 729239) (8 729269) (9 729299) (10 729328) (11 729358))
  182.     (1998 (12 729388) (1 729417) (2 729447) (3 729476) (4 729505) (5 729535)
  183.           (5.5 729564) (6 729593) (7 729623) (8 729653) (9 729682) (10 729712)
  184.           (11 729742))
  185.     (1999 (12 729771) (1 729801) (2 729831) (3 729860) (4 729889) (5 729919)
  186.           (6 729948) (7 729977) (8 730007) (9 730036) (10 730066) (11 730096))
  187.     (2000 (12 730126) (1 730155) (2 730185) (3 730215) (4 730244) (5 730273)
  188.           (6 730303) (7 730332) (8 730361) (9 730391) (10 730420) (11 730450)))
  189.   "An assoc list of Chinese year structures as determined by `chinese-year'.
  190.  
  191. Values are computed as needed, but to save time, the initial value consists
  192. of the precomputed years 1989-2000.  The code works just as well with this
  193. set to nil initially (which is how the value for 1989-2000 was computed).")
  194.  
  195. (defun chinese-year (y)
  196.   "The structure of the Chinese year for Gregorian year Y.
  197. The result is a list of pairs (i d), where month i begins on absolute date d,
  198. of the Chinese months from the Chinese month following the solstice in
  199. Gregorian year Y-1 to the Chinese month of the solstice of Gregorian year Y.
  200.  
  201. The list is cached for further use."
  202.   (let ((list (cdr (assoc y chinese-year-cache))))
  203.     (if (not list)
  204.         (progn
  205.           (setq list (compute-chinese-year y))
  206.           (setq chinese-year-cache
  207.                 (append chinese-year-cache (list (cons y list))))))
  208.     list))
  209.  
  210. (defun number-chinese-months (list start)
  211.   "Assign month numbers to the lunar months in LIST, starting with START.
  212. Numbers are assigned sequentially, START, START+1, ..., 11, with half
  213. numbers used for leap months.
  214.  
  215. First month of list will never be a leap month, nor will the last."
  216.   (if list
  217.       (if (zerop (- 12 start (length list)))
  218.           ;; List is too short for a leap month
  219.           (cons (list start (car list))
  220.                 (number-chinese-months (cdr list) (1+ start)))
  221.         (cons
  222.          ;; First month
  223.          (list start (car list))
  224.          ;; Remaining months
  225.          (if (and (cdr (cdr list));; at least two more months...
  226.                   (<= (car (cdr (cdr list)))
  227.                       (chinese-zodiac-sign-on-or-after (car (cdr list)))))
  228.              ;; Next month is a leap month
  229.              (cons (list (+ start 0.5) (car (cdr list)))
  230.                    (number-chinese-months (cdr (cdr list)) (1+ start)))
  231.            ;; Next month is not a leap month
  232.            (number-chinese-months (cdr list) (1+ start)))))))
  233.  
  234. (defun chinese-month-list (start end)
  235.   "List of starting dates of Chinese months from START to END."
  236.   (if (<= start end)
  237.       (let ((new-moon (chinese-new-moon-on-or-after start)))
  238.         (if (<= new-moon end)
  239.             (cons new-moon
  240.                   (chinese-month-list (1+ new-moon) end))))))
  241.  
  242. (defun compute-chinese-year (y)
  243.   "Compute the structure of the Chinese year for Gregorian year Y.
  244. The result is a list of pairs (i d), where month i begins on absolute date d,
  245. of the Chinese months from the Chinese month following the solstice in
  246. Gregorian year Y-1 to the Chinese month of the solstice of Gregorian year Y."
  247.   (let* ((next-solstice (chinese-zodiac-sign-on-or-after
  248.                          (calendar-absolute-from-gregorian
  249.                           (list 12 15 y))))
  250.          (list (chinese-month-list (1+ (chinese-zodiac-sign-on-or-after
  251.                                         (calendar-absolute-from-gregorian
  252.                                          (list 12 15 (1- y)))))
  253.                                    next-solstice))
  254.          (next-sign (chinese-zodiac-sign-on-or-after (car list))))
  255.     (if (= (length list) 12)
  256.         ;; No room for a leap month, just number them 12, 1, 2, ..., 11
  257.         (cons (list 12 (car list))
  258.               (number-chinese-months (cdr list) 1))
  259.       ;; Now we can assign numbers to the list for y
  260.       ;; The first month or two are special
  261.       (if (or (> (car list) next-sign) (>= next-sign (car (cdr list))))
  262.           ;; First month on list is a leap month, second is not
  263.           (append (list (list 11.5 (car list))
  264.                         (list 12 (car (cdr list))))
  265.                   (number-chinese-months (cdr (cdr list)) 1))
  266.         ;; First month on list is not a leap month
  267.         (append (list (list 12 (car list)))
  268.                 (if (>= (chinese-zodiac-sign-on-or-after (car (cdr list)))
  269.                         (car (cdr (cdr list))))
  270.                     ;; Second month on list is a leap month
  271.                     (cons (list 12.5 (car (cdr list)))
  272.                           (number-chinese-months (cdr (cdr list)) 1))
  273.                   ;; Second month on list is not a leap month
  274.                   (number-chinese-months (cdr list) 1)))))))
  275.  
  276. (defun calendar-absolute-from-chinese (date)
  277.   "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE.
  278. The Gregorian date Sunday, December 31, 1 BC is imaginary."
  279.   (let* ((cycle (car date))
  280.          (year (car (cdr date)))
  281.          (month (car (cdr (cdr date))))
  282.          (day (car (cdr (cdr (cdr date)))))
  283.          (g-year (+ (* (1- cycle) 60);; years in prior cycles
  284.                     (1- year)        ;; prior years this cycle
  285.                     -2636)))         ;; years before absolute date 0
  286.     (+ (1- day);; prior days this month
  287.        (car
  288.         (cdr    ;; absolute date of start of this month
  289.          (assoc month (append (memq (assoc 1 (chinese-year g-year))
  290.                                     (chinese-year g-year))
  291.                               (chinese-year (1+ g-year)))))))))
  292.  
  293. (defun calendar-chinese-from-absolute (date)
  294.   "Compute Chinese date (cycle year month day) corresponding to absolute DATE.
  295. The absolute date is the number of days elapsed since the (imaginary)
  296. Gregorian date Sunday, December 31, 1 BC."
  297.   (let* ((g-year (extract-calendar-year
  298.                   (calendar-gregorian-from-absolute date)))
  299.          (c-year (+ g-year 2695))
  300.          (list (append (chinese-year (1- g-year))
  301.                        (chinese-year g-year)
  302.                        (chinese-year (1+ g-year)))))
  303.     (while (<= (car (cdr (car (cdr list)))) date)
  304.       ;; the first month on the list is in Chinese year c-year
  305.       ;; date is on or after start of second month on list...
  306.       (if (= 1 (car (car (cdr list))))
  307.           ;; second month on list is a new Chinese year
  308.           (setq c-year (1+ c-year)))
  309.       ;; ...so first month on list is of no interest
  310.       (setq list (cdr list)))
  311.     (list (/ (1- c-year) 60)
  312.           (calendar-mod c-year 60)
  313.           (car (car list))
  314.           (1+ (- date (car (cdr (car list))))))))
  315.  
  316. (defun holiday-chinese-new-year ()
  317.   "Date of Chinese New Year."
  318.   (let ((m displayed-month)
  319.         (y displayed-year))
  320.     (increment-calendar-month m y 1)
  321.     (if (< m 5)
  322.         (let ((chinese-new-year
  323.                (calendar-gregorian-from-absolute
  324.                 (car (cdr (assoc 1 (chinese-year y)))))))
  325.           (if (calendar-date-is-visible-p chinese-new-year)
  326.           (list
  327.            (list chinese-new-year
  328.                  (format "Chinese New Year (%s)"
  329.                          (calendar-chinese-sexagesimal-name (+ y 57))))))))))
  330.  
  331. (defun calendar-chinese-date-string (&optional date)
  332.   "String of Chinese date of Gregorian DATE.
  333. Defaults to today's date if DATE is not given."
  334.   (let* ((a-date (calendar-absolute-from-gregorian
  335.                   (or date (calendar-current-date))))
  336.          (c-date (calendar-chinese-from-absolute a-date))
  337.          (cycle (car c-date))
  338.          (year (car (cdr c-date)))
  339.          (month (car (cdr (cdr c-date))))
  340.          (day (car (cdr (cdr (cdr c-date)))))
  341.          (this-month (calendar-absolute-from-chinese
  342.                       (list cycle year month 1)))
  343.          (next-month (calendar-absolute-from-chinese
  344.                       (list (if (= year 60) (1+ cycle) cycle)
  345.                             (if (= (floor month) 12) (1+ year) year)
  346.                             (calendar-mod (1+ (floor month)) 12)
  347.                             1)))
  348.          (m-cycle (% (+ (* year 5) (floor month)) 60)))
  349.     (format "Cycle %s, year %s (%s), %smonth %s%s, day %s (%s)"
  350.             cycle
  351.             year (calendar-chinese-sexagesimal-name year)
  352.             (if (not (integerp month))
  353.                 "second "
  354.               (if (< 30 (- next-month this-month))
  355.                   "first "
  356.                 ""))
  357.             (floor month)
  358.             (if (integerp month)
  359.                 (format " (%s)" (calendar-chinese-sexagesimal-name
  360.                                  (+ (* 5 year) month 44)))
  361.               "")
  362.             day (calendar-chinese-sexagesimal-name (+ a-date 15)))))
  363.  
  364. (defun calendar-chinese-sexagesimal-name (n)
  365.   "The N-th name of the Chinese sexagesimal cycle.
  366. N congruent to 1 gives the first name, N congruent to 2 gives the second name,
  367. ..., N congruent to 60 gives the sixtieth name."
  368.   (format "%s-%s"
  369.           (aref chinese-calendar-celestial-stem (% (1- n) 10))
  370.           (aref chinese-calendar-terrestrial-branch (% (1- n) 12))))
  371.  
  372. (defun calendar-print-chinese-date ()
  373.   "Show the Chinese date equivalents of date."
  374.   (interactive)
  375.   (message "Computing Chinese date...")
  376.   (message "Chinese date: %s"
  377.            (calendar-chinese-date-string (calendar-cursor-to-date t))))
  378.  
  379. (defun calendar-goto-chinese-date (date &optional noecho)
  380.   "Move cursor to Chinese date DATE.
  381. Echo Chinese date unless NOECHO is t."
  382.   (interactive
  383.    (let* ((c (calendar-chinese-from-absolute
  384.               (calendar-absolute-from-gregorian
  385.                (calendar-current-date))))
  386.           (cycle (calendar-read
  387.                   "Chinese calendar cycle number (>44): "
  388.                   '(lambda (x) (> x 44))
  389.                   (int-to-string (car c))))
  390.           (year (calendar-read
  391.                  "Year in Chinese cycle (1..60): "
  392.                  '(lambda (x) (and (<= 1 x) (<= x 60)))
  393.                  (int-to-string (car (cdr c)))))
  394.           (month-list (make-chinese-month-assoc-list
  395.                        (chinese-months cycle year)))
  396.           (month (cdr (assoc
  397.                        (completing-read "Chinese calendar month: "
  398.                                         month-list nil t)
  399.                        month-list)))
  400.           (last (if (= month
  401.                        (car (cdr (cdr
  402.                                   (calendar-chinese-from-absolute
  403.                                    (+ 29
  404.                                       (calendar-absolute-from-chinese
  405.                                        (list cycle year month 1))))))))
  406.                     30
  407.                   29))
  408.           (day (calendar-read
  409.                 (format "Chinese calendar day (1-%d): " last)
  410.                 '(lambda (x) (and (<= 1 x) (<= x last))))))
  411.      (list (list cycle year month day))))
  412.   (calendar-goto-date (calendar-gregorian-from-absolute
  413.                        (calendar-absolute-from-chinese date)))
  414.   (or noecho (calendar-print-chinese-date)))
  415.  
  416. (defun chinese-months (c y)
  417.   "A list of the months in cycle C, year Y of the Chinese calendar."
  418.   (let* ((l (memq 1 (append
  419.                      (mapcar '(lambda (x)
  420.                                 (car x))
  421.                              (chinese-year (extract-calendar-year
  422.                                             (calendar-gregorian-from-absolute
  423.                                              (calendar-absolute-from-chinese
  424.                                               (list c y 1 1))))))
  425.                      (mapcar '(lambda (x)
  426.                                 (if (> (car x) 11) (car x)))
  427.                              (chinese-year (extract-calendar-year
  428.                                             (calendar-gregorian-from-absolute
  429.                                              (calendar-absolute-from-chinese
  430.                                               (list (if (= y 60) (1+ c) c)
  431.                                                     (if (= y 60) 1 y)
  432.                                                     1 1))))))))))
  433.     l))
  434.  
  435. (defun make-chinese-month-assoc-list (l)
  436.   "Make list of months L into an assoc list."
  437.   (if (and l (car l))
  438.       (if (and (cdr l) (car (cdr l)))
  439.           (if (= (car l) (floor (car (cdr l))))
  440.               (append
  441.                (list (cons (format "%s (first)" (car l)) (car l))
  442.                      (cons (format "%s (second)" (car l)) (car (cdr l))))
  443.                (make-chinese-month-assoc-list (cdr (cdr l))))
  444.             (append
  445.              (list (cons (int-to-string (car l)) (car l)))
  446.              (make-chinese-month-assoc-list (cdr l))))
  447.         (list (cons (int-to-string (car l)) (car l))))))
  448.  
  449. (defun diary-chinese-date ()
  450.   "Chinese calendar equivalent of date diary entry."
  451.   (format "Chinese date: %s" (calendar-chinese-date-string date)))
  452.  
  453. (provide 'cal-china)
  454.  
  455. ;;; cal-china.el ends here
  456.